Business Shareware

home *** CD-ROM | disk | FTP | other *** search

/ Business Shareware / Business Shareware.iso / start / database / lib194 / windows.prg < prev

Wrap

Text File | 1993-01-19 | 58.8 KB | 1,609 lines

*------------------------------------------------------------------------------- *-- Program...: WINDOWS.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 06/19/1992 *-- Notes.....: This set of functions was published in the JUNE, 1992 issue of *-- Technotes for dBASE IV (Vol. 90). The routines were created *-- by Adam Menkes, except for the ones added in (used by a couple *-- of the functions) that were written by Jay Parsons. *-- For a complete explanation on how these routines work, you need *-- to read the article in TechNotes. I have entered the routines, *-- and added the standard DUFLP notation at the beginning, and *-- once this issue of TN has been posted on the BORBBS, this file *-- will be added to the 'current' version of LIBxx.ZIP. *------------------------------------------------------------------------------- FUNCTION Alert *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *--Notes.......: This routine creates a popup on the screen with a title and *-- one line message, forcing the user to notice the message. *-- The user must use the mouse on the 'OK' pad, press <Esc> or *-- press <Enter> to move on in the program that called this *-- function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/19/1992 - Modified to accept the <Enter> key by Ken Mayer, *-- also a bit better cleanup at the end (releasing things from *-- memory, and so on). *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Alert("<cTitle>","<cMessage>") *-- Example.....: lX = Alert("Print Aborted","You pressed <ESC>") *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 79 characters) *------------------------------------------------------------------------------- parameters cTitle, cMessage private wWindow,nRow,nCol,mPad wWindow = WINDOW() && save current Window save screen to sTemp && save the screen activate screen nRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) && center from top-bottom nCol = 38 - (max(len(cTitle),len(cMessage))/2) && center left-right nCol2 = max(len(cTitle),len(cMessage)) && right side? *-- clear out a section of the screen @nRow,nCol Clear to nRow+6,nCol+nCol2 *-- fill in a box @nRow,nCol Fill to nRow+6,nCol+nCol2+1 color n+ && grey *-- put a double line border around box @nRow,nCol to nRow+6,nCol+nCol2+1 double color bg+ *-- display title @nRow + 1,nCol + 1 + iif(len(cTitle) > len(cMessage),0,; (len(cMessage)-len(cTitle)) / 2) say cTitle color w+/n *-- display line @nRow + 2, nCol + 1 to nRow + 2, nCol + nCol2 color bg+ *-- display message @nRow + 3, nCol+1+iif(len(cTitle) > len(cMessage),; (len(cTitle)-len(cMessage)) / 2, 0) say cMessage color w+/n *-- define/display a very small menu (one pad) define menu mAlert define pad pPad1 of mAlert prompt " OK " at nRow +5,37 on selection pad pPad1 of mAlert deactivate menu *-- added by Ken to deal with <Enter> on key label ctrl-M keyboard "{27}" *-- start it up activate menu mAlert *-- deal with user 'input' mPad = pad() *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # wWindow activate window &wWindow endif RETURN .not. "" = mPad && not empty pad? *-- EoF: Alert() FUNCTION CheckBox *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This routine brings up a one-line message, allows the user *-- to click mouse/press <Space> on it, to change status. *-- Pressing <Enter>/<Esc> chooses the current setting ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: CheckBox(<lVar>,"<cTitle>",<nRow>,<nCol>,<nASCII>) *-- Example.....: lX = CheckBox(.t.,"OK as is?",9,10,4) *-- Returns.....: Logical *-- Parameters..: lVar = On or Off to start? (.t.=on, .f.=off) *-- cTitle = Title/Message *-- nRow = Row to place this *-- nCol = Column ... *-- nASCII = ascii character to use in box. (Optional) *-- Default is 251 (√). Other suggestions include: *-- 4 (diamond), 176 (░), 177 (▒), 178 (▓), *-- 219 (█), 249 (∙), 250 (·), 254 (■) *-- (Check out the ASCII chart in the language ref.) *------------------------------------------------------------------------------- parameters lVar, cTitle, nRow, nCol, nASCII *-- if parameter is left blank, assign 251 (√) nASCII = iif(pCount() = 5, nASCII, 251) define menu mCheck *-- loop until user does something, or presses <Esc> do while .t. *-- define the menu pad ... define pad pCheck1 of mCheck at nRow,nCol prompt; "["+iif(lVar,chr(nASCII)," ")+"] "+cTitle on selection pad pCheck1 of mCheck deactivate menu *-- when user presses <Enter> turn it all off ... (send <Esc> ...) on key label ctrl-m keyboard "{27}" *-- start 'er up activate menu mCheck *-- (<Esc> or <Enter>) if lastkey() = 27 exit endif lVar = .not. lVar && set to opposite of current setting enddo *-- reset environment/release things on key label ctrl-m release menu mCheck RETURN lVar *-- EoF: CheckBox() Function CheckBx1 *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This routine brings up a one-line message, allows the user *-- to click mouse/press <Space> on it, to change status. *-- Pressing <Enter>/<Esc> chooses the current setting ... *-- This one is different, in that it does not use a menu to *-- accomplish it's ends, but uses instead a memvar, with *-- @/GET/READ and a picture using the multiple choice ("@M") *-- function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: CheckBx1(<lVar>,"<cTitle>",<nRow>,<nCol>) *-- Example.....: lX = CheckBx1(.t.,"OK as is?",9,10) *-- Returns.....: Logical *-- Parameters..: lVar = On or Off to start? (.t.=on, .f.=off) *-- cTitle = Title/Message *-- nRow = Row to place this *-- nCol = Column ... *------------------------------------------------------------------------------- parameters lVar, cTitle, nRow, nCol *-- save parts of environment ... cFormat = set("FORMAT") set format to cCursor = set("CURSOR") set cursor off *-- define starting value of cVar ... *-- (this is ASCII 255, √, ASCII 255, if lVar = .t., 3 spaces if lVar = .f.) cVar = iif(lVar,chr(255)+chr(251)+chr(255),space(3)) *-- display/get, using picture @nRow,nCol get cVar picture "@M , √ " *-- this picture is: space, comma, chr(255), chr(251), chr(255). @nRow,nCol + 4 say cTitle READ *-- reset environment set format to &cFormat set cursor &cCursor RETURN .not. (cVar = chr(32)) && not a space *-- EoF: CheckBx1() FUNCTION DropDown *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This function performs a picklist of a different sort. *-- In order to use it, you will either use an ARRAY (one-dim) *-- or a field in a database. It holds a choice in a 'holding *-- area', allowing the user to leave it there, and maybe to *-- change it with another option in the list. *-- *-- I recommend you display an on-screen message for this one, *-- because it's not real intuitive (at least not to me). *-- To bring up the list, click on the arrows, to select an item, *-- click on the item, or highlight and press <enter>. To *-- Change, click (or select) another item. To choose the actual *-- item you want, click on the one NEXT to the arrows (or use *-- the arrow keys to select that menu pad, and press <Enter>). *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: TEMPNAME() Function in WINDOWS.PRG *-- ARRAYROWS() Function in WINDOWS.PRG *-- ARRAYCOLS() Function in WINDOWS.PRG *-- FIELDNUM() Function in WINDOWS.PRG *-- Called by...: Any *-- Usage.......: DropDown("<cType>","<cName>",[<nRow>,[<nCol>,[<nSize>]]]) *-- Example.....: x=DropDown("F","Lastname",10,15,6) *-- *-- Here is a suggested use: *-- @5,10 get cName when calldrop() && function below *-- read *-- *-- do other stuff *-- FUNCTION CallDrop *-- *-- display message about how to use *-- @18,10 say "<Enter> or Click mouse on "+chr(23)+; *-- " to see list" *-- @19,10 say "<Enter> or Click mouse on name at top to select" *-- *-- call it ... if using a FIELD in the database, you might *-- *-- want to use a temp var, and then *-- *-- REPLACE <field> WITH ... *-- cName = dropdown("F","NAME",6,10,5) && call dropdown func. *-- *-- redisplay it and clean out the 'gets' from memory *-- @5,10 get cName *-- clear gets *-- keyboard chr(23) && move on to next field ... *-- RETURN .T. *-- *-- Returns.....: Selected item *-- Parameters..: cType = 'F' = Field, 'A' = Array (1-Dimensional) *-- cName = Field or Array name *-- nRow = Coordinates to display menu *-- nCol = Same *-- nSize = Number of items to display below dropdown box *------------------------------------------------------------------------------- parameters cType, cName, nRow, nCol, nSize *-- If these optional parms are NOT passed, we need to set default *-- values ... nSize = iif(pcount() <= 4, 5, nSize) nCol = iif(pCount() <= 3,10, nCol) nRow = iif(pCount() <= 2, 5, nRow) *-- setup nMaxLen = 1 lNone = (set("BORDER") = "NONE") define menu mDropDown *-- if it's an array, we work here for setup ... if upper(cType) = "A" nCols = arraycols(cName) nRows = arrayrows(cName) *-- determine width of display, by scanning each element of *-- array and finding the largest ... nX = 1 do while nX <= nCols nMaxLen = Max(nMaxLen, len(&cName[nX])) nX = nX + 1 enddo *-- here we're gonna define the popup part of it ... define popup pDropDown from nRow+iif(lNone,0,1),; nCol-iif(lNone,1,0) to nRow+nSize+; iif(lNone,1,2),nCol+nMaxLen+iif(lNone,0,1) *-- define the bars ... the loops have to be done seperate, *-- since the width must be determined before the bars are defined. nX = 1 do while nX <= nCols define bar nX of DropDown prompt &cName[nX] nX = nX + 1 enddo else *-- process if it's a field here do case case type ("&cName") = "C" && character calculate max(len(trim(&cName))) to nMaxLen case type ("&cName") $ "FN" && numeric (or floating) cAlias = alias() dbftemp = tempname("DBF") nNum = fieldnum(cName) copy structure extended to (dbfTemp) select select() use (dbftemp) exclusive nosave go nNum nMaxLen = field_Len use select (cAlias) case type ("&cName") = "D" nMaxLen = iif(set("CENTURY") = "ON",10,8) case type ("&cName") = "L" nMaxLen = 1 endcase define popup pDropdown from nRow + iif(lNone,0,1),nCol-; iif(lNone,1,0) to nRow+nSize+iif(lNone,1,2),; nCol+nMaxLen+iif(lNone,0,1) prompt field &cName endif *-- define the pad that activates this thing ... define pad pPad2 of mDropDown prompt chr(23) at nRow,nCol+nMaxLen on selection pad pPad2 of mDropDown activate popup pDropDown on selection popup pDropDown deactivate menu do while lastkey() # 27 xPrompt = trim(prompt())+space(nMaxLen - len(trim(prompt()))) define pad pPad1 of mDropDown prompt xPrompt at nRow,nCol on selection pad pPad1 of mDropDown deactivate menu activate menu mDropDown pad pPad2 if pad() = "PPAD1" exit endif enddo release popup pDropDown release menu mDropDown RETURN trim(prompt()) *-- EoF: DropDown() FUNCTION MsWind *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This one creates a window that acts like one from WINDOWS, *-- in that you can move it, enlarge it to full-screen, and *-- bring it back to its original size. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: MOVEWINU Procedure in WINDOWS.PRG *-- MOVEWIND Procedure in WINDOWS.PRG *-- ENLARGE Procedure in WINDOWS.PRG *-- MSWINACT Procedure in WINDOWS.PRG *-- Called by...: Any *-- Usage.......: MsWind(<nTop>,<nLeft>,<nLower>,<nRight>) *-- Example.....: x=MsWind(5,10,20,70) *-- Returns.....: Logical *-- Parameters..: nTop = Top Row of window *-- nLeft = Left column *-- nBottom = Bottom Row of Window *-- nRight = Right column *------------------------------------------------------------------------------- parameters nTop, nLeft, nLower, nRight *-- save environment save screen to sMSWIND lStatus = (set("STATUS") = "ON") lDisp43 = ("43" $ SET("DISPLAY")) *-- loop do while .t. restore screen from sMSWIND *-- define/redefine window area and box @nTop, nLeft clear to nLower, nRight @nTop, nLeft TO nLower, nRight *-- using menus to simulate Windows window ... define menu wNormal define pad pCabinet of wNormal prompt "["+chr(254)+"]"; at nTop, nLeft + 1 && ■ define pad pMoveUp of wNormal prompt chr(18) ; at nTop, nRight - 4 && up/down-arrow define pad pEnlarge of wNormal prompt chr(30) ; at nTop, nRight - 1 && up-arrow-head define pad pMoveDn of wNormal prompt chr(18) ; at nLower, nRight - 4 && up/down arrow again *-- tell it what to do when an item is selected on selection pad pCabinet of wNormal deactivate menu on selection pad pMoveUp of wNormal do movewinu on selection pad pEnlarge of wNormal do enlarge on selection pad pMoveDn of wNormal do movewind *-- deal with changes ... do mswinact with nTop, nLeft activate menu wnormal *-- User pressed <Esc> or chose the 'close window' button/pad if lastkey() = 27 .or. "PCABINET" = pad() exit endif enddo && end of loop *-- restore environment restore screen from sMSWIND release screen sMSWIND release menu wNormal RETURN .not. "" = pad() *-- EoF: MSWind() PROCEDURE Enlarge *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to 'enlarge' the a window, and redfine *-- the menu ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: MsWinAct Procedure in WINDOWS.PRG *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do Enlarge *-- Example.....: Do Enlarge *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- *-- clear screen, draw border from upper left to a bottom right corner ... clear @0,0 to iif(lStatus,21,24) + iif(lDisp43,18,0), 79 *-- define new version of menu define menu mEnlarge define pad pCabinet of mEnlarge prompt "["+chr(254)+"]" at 0,2 define pad pReduce of mEnlarge prompt chr(31) at 0,78 on selection pad pCabinet of mEnlarge deactivate menu on selection pad pReduce of mEnlarge deactivate menu *-- Routine to allow interaction inside menu window ... do mswinact with 0,0 *-- start 'er up activate menu mEnlarge deactivate menu if lastkey() = 27 keyboard "{27}" endif release menu mEnlarge clear RETURN *-- EoP: Enlarge PROCEDURE MoveWinU *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to move the window up (unless the *-- window is at the top of the screen ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MoveWinU *-- Example.....: Do MoveWinU *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- *-- check for top of screen ... change coordinates nTop = nTop - iif(nTop = 0,0,1) nLower = nLower - iif(nTop = 0,0,1) deactivate menu RETURN *-- EoP: MoveWinU PROCEDURE MoveWinD *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to move the window down (unless the *-- window is at the bottom of the screen ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MoveWinD *-- Example.....: Do MoveWinD *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- *-- check for bottom of screen/status line ... change coordinates nTop = nTop + iif(nLower = iif(lStatus,21,24)+; iif(lDisp43,18,0),0,1) nLower = nLower + iif(nLower=iif(lStatus,21,24)+; iif(lDisp43,18,0),0,1) deactivate menu RETURN *-- EoP: MoveWinD PROCEDURE MSWinAct *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to move the actually display/redisplay *-- information inside the window, even when a window has been *-- moved. This routine should be modified for a specific *-- system ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MSWinAct with <nTop>, <nLeft> *-- Example.....: Do MSWinAct with 5,10 *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- parameters nTop, nLeft private nTop, nLeft @nTop + 2, nLeft + 2 say "This is line 1" @nTop + 3, nLeft + 2 say "And this is line 2" RETURN *-- EoP: MSWinAct FUNCTION RadioBut *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This is a Radio Button routine. NOTE that the array called as *-- cArray below must be a character array (i.e., all data must *-- be character data ...). *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: ArrayCols() Function in WINDOWS.PRG *-- TmpRadio Procedure in WINDOWS.PRG *-- Called by...: None *-- Usage.......: RadioBut("<cArray>",<nRow>,<nCol>,<nDefPad>,<nASCII>) *-- Example.....: nReturn = RadioBut("aTest",5,10,1,15) *-- Returns.....: Numeric (Array Index of item selected) *-- Parameters..: cArray = Name of Array (Charater data) *-- nRow = Row for coordinates ... (start position) *-- nCol = Column for same *-- nDefPad = Default Pad number *-- nASCII = ASCII character to use as 'button' (Optional ...) *-- try: 4 (Diamond), 9 (Circle), 15 (splot), 42 (*), 249 (∙), *-- 251 (√) or 254 (■) ... *------------------------------------------------------------------------------- parameters cArray, nRow, nCol, nDefPad, nASCII define menu mRadio public aTmpRadio, nARows, nPad *-- get number of items to display nARows = ArrayRows(cArray) *-- set character for 'button' nASCII = iif(PCOUNT() <= 4,4,nASCII) && default is a 'diamond' *-- start definitions ... cPad = iif(pcount() => 4 .and. nDefPad # 0, ltrim(str(nDefPad)),"1") nCol = iif(pcount() <= 2,10,nCol) nRow = iif(pCount() <= 1,5,nRow) *-- here we get the largest item in the array ... nX = 1 nLongest = 1 do while nX <= nARows nLongest = max(nLongest,len(trim(&cArray[nX]))) nX = nX + 1 enddo *-- define a temporary array ... declare aTmpRadio[nARows] on key label ctrl-m keyboard "{27}" && close down if <Enter> ... cX = "1" do while .t. *-- define menu pads do while val(cX) <= nARows define pad button&cX of mRadio at nRow - 1 + val(cX),nCol; prompt "("+ iif(aTmpRadio[val(cX)] .or. cPad = cX,; chr(nASCII)," ")+") "+trim(&cArray[val(cX)])+; space(nLongest-len(trim(&cArray[val(cX)]))) on selection pad button&cX of mRadio deactivate menu cX = ltrim(str(val(cX)+1)) enddo *-- start 'er up activate menu mRadio pad button&nPad *-- if <Esc> (or <Enter>), we're done ... if lastkey() = 27 nPad = substr(pad(),7) exit else *-- if not, perform routine below to reset the temp array ... do TmpRadio endif enddo *-- cleanup on key label ctrl-m ny = 1 do while ny <= nARows .and. .not. aTmpRadio[nY] nY = nY + 1 enddo release aTmpRadio, nPad release menu mRadio RETURN iif(nY > nARows, 0, nY) *-- EoF: RadioBut() PROCEDURE TmpRadio *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used to set/reset the temporary array aTmpRadio[] for use *-- in the RadioBut() function above. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: RadioBut() Function in WINDOWS.PRG *-- Usage.......: Do TmpRadio *-- Example.....: Do TmpRadio *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- nPad = substr(pad(),7) nY = 1 do while nY <= nARows aTmpRadio[nY] = .f. nY = nY + 1 enddo aTmpRadio[val(nPad)] = .t. cX = "1" RETURN *-- EoP: TmpRadio FUNCTION ScrolBar *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Performs a horizontal scroll-bar to find a record in a *-- database file. Note that this function assumes a database *-- is open. Not quite sure how I'd use this one ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: None *-- Usage.......: ScrolBar(<nAtLine>) *-- Example.....: This example is from the text of Adam's article: *-- Add the following line to your program or FMT file: *-- *-- ON KEY LABEL F5 DO MoveRec *-- *-- Create a simple PROCEDURE or program with the following: *-- *-- PROCEDURE MoveRec *-- on key label ctrl-M chr(27) && press <Enter> to return *-- x=scrolbar(20) && call function *-- on key label ctrl-M && reset CTRL-M key *-- RETURN *-- *-- Returns.....: .T. *-- Parameters..: nAtLine = Line of screen (ROW) to display scroll bar at. *------------------------------------------------------------------------------- parameters nAtLine nAtLine = iif(pCount() = 1, nAtLine, 20) nBreak = 76 cx = "1" ny = 1 nRecord = reccount() nZ = (nBreak/nRecord) - int(nBreak/nRecord) *-- once again, this is being done via a menu ... define menu mScrollBar define pad pPad0 of mScrollBar prompt chr(17) at nAtLine, 1 *-- if the first pad is selected, back up one record on selection pad pPad0 of mScrollBar skip iif(bof(),0,-1) *-- deal with location of the rest ... do while val(cX) <= nRecord if nRecord <= nBreak define pad pPad&cX of mScrollBar ; prompt; space((nBreak/nRecord)+iif(nZ => 1, int(nZ),0)) at nAtLine, nY + 1 endif nY = nY + int(nBreak/nRecord)+iif(nZ => 1, int(nZ),0) if nZ => 1 nZ = nZ - int(nZ) endif nZ = nZ + (nBreak / nRecord) - int(nBreak/nRecord) on selection pad pPad&cX of mScrollBar go val(substr(pad(),4)) cX = ltrim(str(val(cX) + 1)) enddo *-- define final pad define pad pPad&cX of mScrollBar prompt chr(16) at nAtLine, nY + 1 on selection pad pPad&cX of mScrollBar skip iif(eof(),0,1) *-- start 'er up ... activate menu mScrollBar RETURN .t. *-- EoF: ScrolBar() *------------------------------------------------------------------------------- *-- This section is where I, Ken Mayer, attempted to modify/improve some of *-- Adam's routines ... I may or may not have been successful, YOU decide ... *-- <g> *------------------------------------------------------------------------------- FUNCTION Alert2 *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This routine creates a popup on the screen with a title and *-- one line message, forcing the user to notice the message. *-- The user must use the mouse on the 'OK' pad, press <Esc> or *-- press <Enter> to move on in the program that called this *-- function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: Modified to accept the <Enter> key by Ken Mayer. *-- 06/19/1992 -- Copied from Adam's original, uses a window, *-- shadow, and programmer defineable colors. *-- 07/29/1992 -- Joey stepped in and made some modifications *-- that seem to have helped as well, including dealing with *-- the keyboard buffer. *-- 10/09/1992 -- minor change -- title is now same color as *-- the "pad". *-- 11/09/1992 -- Joey Carroll added some minor changes for *-- cosmetics, as well as keeping the colors working *-- properly. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- JUSTIFY() Function in WINDOWS.PRG *-- Called by...: Any *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>") *-- Example.....: lX = Alert2("Print Aborted","You pressed <ESC>",; *-- "rg+/r,w+/b,rg+/r") *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 75 characters) *-- cColor = Colors: <window forg/back>,<pad> (and title),<box> *------------------------------------------------------------------------------- parameters cTitle, cMessage, cColor private wWindow,nRow,nCol,mPad,cTempCol wWindow = WINDOW() && save current Window save screen to sTemp && save the screen i=inkey() && clear out keyboard buffer *-- get window coordinates *-- this centers from top to bottom, depending on monitor setup ... nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) *-- add 6, so the Window is large enough ... nBRRow = nULRow + 6 *-- left column ... nULCol = 36 - (max(len(cTitle),len(cMessage))/2) && center left-right *-- right column ... nBRCol = nULCol + max(len(cTitle),len(cMessage))+4 && right side? *-- Window width ... nWidth = nBRCol - nULCol - 1 *-- define window Define window wAlert from nULRow,nULCol to nBRRow,nBRCol DOUBLE ; color &cColor. activate screen *-- display shadow do shadow with nULRow,nULCol,nBRRow,nBRCol *-- start 'er up ... activate window wAlert *-- display title cTempCol = colorbrk(cColor,2) if len(cTitle) < nWidth cTitle = justify(cTitle,nWidth,"C") if len(cTitle) < nWidth cTitle = cTitle + " " endif endif do center with 0,nWidth,"&cTempCol",cTitle *-- display line cTempCol = colorbrk(cColor,1) @1,0 say replicate(chr(196),nWidth) color &cTempCol *-- display message do center with 2,nWidth,"",cMessage *-- define/display a very small menu (one pad) define menu mAlert define pad pPad1 of mAlert prompt "[OK]" at 4,(nWidth/2)-1 on selection pad pPad1 of mAlert deactivate menu *-- added by Ken to deal with <Enter> on key label ctrl-M keyboard "{27}" *-- start it up activate menu mAlert *-- deal with user 'input' mPad = pad() deactivate window wAlert release window wAlert *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # wWindow activate window &wWindow endif RETURN .not. "" = mPad && not empty pad? *-- EoF: Alert2() FUNCTION MsWind2 *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: This one creates a window that acts like one from WINDOWS, *-- in that you can move it, enlarge it to full-screen, and *-- bring it back to its original size. *-- NOTE: The Title is NOT displaying in the EXPANDED Window. *-- This is based on a KNOWN BUG, forwarded to development. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/23/1992 -- Ken Mayer -- Attempts made to use a 'real' *-- window (a dBASE defined window), shadows, colors, and make *-- the window look more like a Microsoft Windows Window. *-- Calls.......: MOVEWIN2 Procedure in WINDOWS.PRG *-- ENLARGE2 Procedure in WINDOWS.PRG *-- MSWINAC2 Procedure in WINDOWS.PRG *-- SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: MsWind2(<nTop>,<nLeft>,<nLower>,<nRight>,"<cColor>",; *-- "<cTitle>") *-- Example.....: x=MsWind2(5,10,20,70,"rg+/gb,w+/b,rg+/gb","This is a title") *-- Returns.....: Logical *-- Parameters..: nTop = Top Row of window *-- nLeft = Left column *-- nBottom = Bottom Row of Window *-- nRight = Right column *-- cColor = Color combinations to be used: *-- <Normal/Unselected pad>,<Selected pad>,<Box> *-- cTitle = Title for first line of window ... *-- NOTE: if the title is longer than can be displayed *-- with the buttons on the first line, it will be *-- truncated ... *------------------------------------------------------------------------------- parameters nTop, nLeft, nLower, nRight, cColor, cTitle *-- save environment save screen to sMSWIND lStatus = (set("STATUS") = "ON") lDisp43 = ("43" $ SET("DISPLAY")) cMSColor = set("ATTRIBUTES") *-- loop do while .t. *-- bring back old screen before defining all this if window() = "WMSWIND" deactivate window wMSWIND endif restore screen from sMSWIND *-- define/redefine window area and box activate screen define window wMSWind from nTop,nLeft to nLower,nRight double; color &cColor do shadow with nTop,nLeft,nLower,nRight activate window wMSWind *-- deal with defining where to display the title (and truncating *-- if necessary) *-- define width and height of window nWidth = nRight - nLeft - 2 && account for border nHeight = nLower - nTop - 2 && ditto nWidth2 = nWidth - 9 && (space used by menu buttons) if len(trim(cTitle)) > (nWidth2 - 2) && leave room for a space on each sd cTitle2 = left(cTitle,nWidth2-2) else cTitle2 = trim(cTitle) endif nSpaces = nWidth2 - len(cTitle2) nSpaces1 = nSpaces/2 nSpaces2 = iif(nSpaces1=int(nSpaces/2),nSpaces1,nSpaces1+1) cTitle2 = space(nSpaces1) + cTitle2 + space(nSpaces2) cTitlCol = colorbrk(cColor,2) @0,3 say cTitle2 color &cTitlCol *-- using menus to simulate Windows window ... define menu wNormal define pad pCabinet of wNormal prompt "["+chr(254)+"]" at 0, 0 define pad pMoveUp of wNormal prompt "["+chr(24)+"]" at 0,nWidth - 6 define pad pEnlarge of wNormal prompt "["+chr(30)+"]" at 0,nWidth - 3 define pad pMoveDn of wNormal prompt "["+chr(25)+"]" ; at nHeight, nWidth - 3 define pad pMoveRt of wNormal prompt "["+chr(26)+"]" ; at nHeight, nWidth - 6 define pad pMoveLf of wNormal prompt "["+chr(27)+"]" ; at nHeight, nWidth - 9 *-- tell it what to do when an item is selected on selection pad pCabinet of wNormal deactivate menu on selection pad pMoveUp of wNormal do movewin with pad() on selection pad pEnlarge of wNormal do enlarge2 with cTitle, cTitlCol on selection pad pMoveDn of wNormal do movewin with pad() on selection pad pMoveRt of wNormal do movewin with pad() on selection pad pMoveLf of wNormal do movewin with pad() *-- Display something in Window do mswinat2 *-- start the menu activate menu wnormal *-- User pressed <Esc> or chose the 'close window' button/pad if lastkey() = 27 .or. "PCABINET" = pad() exit endif enddo && end of loop *-- restore environment deactivate window wMSWind release window wMSWind restore screen from sMSWIND release screen sMSWIND release menu wNormal RETURN .not. "" = pad() *-- EoF: MSWind() PROCEDURE Enlarge2 *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND() to 'enlarge' the a window, and redfine *-- the menu ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/23/1992 -- Ken Mayer (CIS: 71333,1030) - redefined to handle *-- using real dBASE Windows ... *-- Calls.......: MsWinAt2 Procedure in WINDOWS.PRG *-- Called by...: MsWind2() Function in WINDOWS.PRG *-- Usage.......: Do Enlarge2 with cTitle, cTitlCol *-- Example.....: Do Enlarge2 with cTitle, cTitlCol *-- Returns.....: None *-- Parameters..: cTitle = Title from MSWIND2() *-- cTitlCol = Title color (also from MSWIND2()) *------------------------------------------------------------------------------- parameters cTitle, cTitlCol *-- do a new version of the window ... deactivate window wMSWind restore screen from sMSWIND activate screen define window wMSWind from 0,0 to iif(lStatus,20,23) + iif(lDisp43,18,0), 77; double color &cColor do shadow with 0,0,iif(lstatus,20,23)+iif(lDisp43,18,0),77 activate window wMSWind *-- deal with TITLE ... *-- deal with defining where to display the title (and truncating *-- if necessary) *-- define width and height of window nWidth = 74 && account for border nWidth2 = nWidth - 6 && (space used by menu buttons) if len(trim(cTitle)) > (nWidth2 - 2) && leave room for a space on each side cTitle2 = left(cTitle,nWidth2-2) else cTitle2 = trim(cTitle) endif nSpaces = nWidth2 - len(cTitle2) nSpaces1 = nSpaces/2 nSpaces2 = iif(nSpaces1=int(nSpaces/2),nSpaces1,nSpaces1+1) cTitle2 = space(nSpaces1) + cTitle2 + space(nSpaces2) @0,3 say cTitle2 color &cTitlCol *-- define new version of menu define menu mEnlarge define pad pCabinet of mEnlarge prompt "["+chr(254)+"]" at 0,0 define pad pReduce of mEnlarge prompt "["+chr(31)+"]" at 0,72 on selection pad pCabinet of mEnlarge deactivate menu on selection pad pReduce of mEnlarge deactivate menu *-- Routine to allow interaction inside menu window ... do mswinat2 *-- start 'er up activate menu mEnlarge if lastkey() = 27 keyboard "{27}" endif deactivate menu deactivate window wMSWIND release window wMSWIND release menu mEnlarge RETURN *-- EoP: Enlarge2 PROCEDURE MoveWin *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 06/23/1992 *-- Notes.......: Used in MSWIND() to move the window up (unless the *-- window is at the top of the screen ...) *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: MsWind() Function in WINDOWS.PRG *-- Usage.......: Do MoveWin with <pPad> *-- Example.....: Do MoveWin with pad() *-- Returns.....: None *-- Parameters..: pPad = menu pad selected to move window ... *------------------------------------------------------------------------------- parameters pPad restore screen from sMSWIND do case case pPad = "PMOVEUP" *-- check for top of screen ... change coordinates nTop = nTop - iif(nTop = 0,0,1) nLower = nLower - iif(nTop = 0,0,1) case pPad = "PMOVEDN" nTop = nTop + iif(nLower = iif(lStatus,21,24)+; iif(lDisp43,18,0),0,1) nLower = nLower + iif(nLower=iif(lStatus,21,24)+; iif(lDisp43,18,0),0,1) case pPad = "PMOVELF" nLeft = nLeft - iif(nLeft = 0,0,1) nRight = nRight - iif(nLeft = 0,0,1) case pPad = "PMOVERT" nRight = nRight + iif(nRight = 79,0,1) nLeft = nLeft + iif(nRight = 79,0,1) endcase deactivate menu RETURN *-- EoP: MoveWin PROCEDURE MSWinAt2 *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT) *-- Date........: 06/01/1992 *-- Notes.......: Used in MSWIND2() to move the actually display/redisplay *-- information inside the window, even when a window has been *-- moved. This routine should be modified for a specific *-- system ... This version (for MSWIND2()) starts counting *-- at the top + 1 -- the first line (0) is for the menu and *-- the title ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/23/1992 -- Modified by Ken Mayer to work with MSWIND2(). *-- Calls.......: None *-- Called by...: MsWind2() Function in WINDOWS.PRG *-- Usage.......: Do MSWinAt2 *-- Example.....: Do MSWinAt2 *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- @1,1 say "This is line 1" @2,1 say "And this is line 2" RETURN *-- EoP: MSWinAt2 FUNCTION Alert3 *------------------------------------------------------------------------------- *-- Programmer..: Adam L. Menkes (SUPREME1) *-- Date........: 12/23/1992 *-- Notes.......: This function based on Alert2() *-- This routine creates a popup on the screen with a title and *-- one line message, forcing the user to notice the message. *-- The user must use the mouse on the 'OK' pad, press <Esc> or *-- press <Enter> to move on in the program that called this *-- function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: Original: 06/19/1992 *-- Alert2() *-- Modified to accept the <Enter> key by Ken Mayer. *-- 06/19/1992 -- Copied from Adam's original, uses a window, *-- shadow, and programmer defineable colors. *-- 07/29/1992 -- Joey stepped in and made some modifications *-- that seem to have helped as well, including dealing with *-- the keyboard buffer. *-- 10/09/1992 -- minor change -- title is now same color as *-- the "pad". *-- Alert22() *-- 11/12/1992 -- changed to look more like a Win 3.0/3.1 *-- window by printing a special 'line' below the title. *-- Also removed hard coding which forced border to DOUBLE *-- so that if called with border set to NONE, gives even more *-- Win-like appearance. Calls a new function written for this *-- technique, but can be used in other programs. *-- 11/16/1992 -- modified to add cBORDER parameter ... (K. Mayer) *-- 12/23/1992 -- tuned up centering of cTitle, cMessage, and *-- [OK] pad. Eliminated calls to Center.prg by using Justify() *-- along with @ say. (Joey Carroll) *-- Calls.......: SHADOW Procedure in PROC.PRG *-- JUSTIFY() Function in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- FBCLRBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>"[,"<cBorder>"]) *-- Example.....: ** if no border, I suggest colors which will contrast *-- with the active screen or window *-- lX = Alert2("Print Aborted","You pressed <ESC>",; *-- "rg+/r,w+/b,rg+/r","NONE") *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 75 characters) *-- cColor = Colors: <window forg/back>,<pad> (and title),<box> *-- cBorder = Border type (DOUBLE, SINGLE, NONE, PANEL) -- *-- optional -- will default to your setting *------------------------------------------------------------------------------- parameters cTitle, cMessage, cColor, cBorder private wWindow,mPad,cTempCol,cColorF,cColorB,cColorAll private nWidth,nULRow,nULCol,nLRRow,nLRCol,cTitle2,cMessage2,nBorder cTitle2 = " " + ltrim(trim(cTitle)) + " " && don't jamb against walls cMessage2 = " " + ltrim(trim(cMessage)) + " " && don't jamb against walls wWindow = WINDOW() && save current Window save screen to sTemp && save the screen activate screen cDummykey = inkey() && clear out keyboard buffer cOldBorder = set("BORDER") && get old border setting if .not. type("CBORDER") = "L" && if user set border ... set border to &cBorder && start NEW border setting endif nBorder = iif(set("BORDER") = "NONE",0,2) && border factor *-- get window coordinates *-- this centers from top to bottom, depending on monitor setup ... nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) *-- add rows, number depends on border, so the Window is large enough ... nBRRow = nULRow + 5 +nBorder *-- left column ... nULCol = 40 - (max(len(cTitle2),len(cMessage2))/2) && center left-right *-- right column ... nBRCol = nULCol + max(len(cTitle2),len(cMessage2)) + (nBorder - 1) *-- Window width ... nWidth = nBRCol - nULCol - 1 *-- define window Define window wAlert from nULRow,nULCol to nBRRow,nBRCol color &cColor. *-- display shadow do shadow with nULRow,nULCol,nBRRow,nBRCol *-- start 'er up ... activate window wAlert *-- display a new type type line to look more like Win cTempCol = colorbrk(cColor,2) cColorF = FBClrBrk("B",cTempCol) && background of title bar text cColorB = FBClrBrk("B",colorbrk(cColor,1)) && foreground of 'normal' text cColorAll = cColorF + "/" + cColorB && color of 'special' line @ 0,0 say justify(cTitle2,nWidth + iif(nBorder = 0,4,2),"C") ; color &cTempCol && the Title Bar *-- chr(223) looks like this --> ▀ <-- @ 1,0 say replicate(chr(223),nWidth + 2) color &cColorAll && make thicker *-- display message @ 2,0 say justify(cMessage2,nWidth + iif(nBorder = 0,4,2),"C") *-- define/display a very small menu (one pad) define menu mAlert define pad pPad1 of mAlert prompt "[OK]" at 4,((nWidth-nBorder-2)/2) on selection pad pPad1 of mAlert deactivate menu *-- added by Ken to deal with <Enter> on key label ctrl-M keyboard "{27}" *-- start it up activate menu mAlert *-- deal with user 'input' mPad = pad() deactivate window wAlert release window wAlert *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # wWindow activate window &wWindow endif set border to &cOldBorder RETURN .not. "" = mPad && not empty pad? *-- EoF: Alert3() FUNCTION YesNo3 *------------------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer *-- Date........: 01/06/1993 *-- Notes.......: A version of the YESNO() routines in PROC.PRG, that will *-- handle a long (up to 254 character) message string, is *-- centered on the screen, and has a title bar kind of like *-- a Windows dialog box ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: Center Procedure in PROC.PRG *-- Shadow Procedure in PROC.PRG *-- WordWrap Procedure in STRINGS.PRG *-- ColorBrk() Function in PROC.PRG *-- FBClrBrk() Function in PROC.PRG *-- Justify() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: YesNo3(<lDefault>,<cTitle>,<cMessage>,<cColor>) *-- Example.....: if YesNo3(.t.,"Test","This is a message of any length"+; *-- "up to 254 characters.",cWind1) *-- Returns.....: logical *-- Parameters..: lDefault = Logical value, for the default menu pad (Yes/No) *-- cTitle = Title for title bar -- no longer than 30 *-- characters. *-- cMessage = Message - up to 254 characters in length. *-- cColor = "Standard" colors for window/menu/box *------------------------------------------------------------------------------- parameters lDefault, cTitle, cMessage, cColor private nULRow, nULCol, nBRRow, nBRCol, nLMargin, nRMargin, lWrap *-- save it, so we can activate the screen and display a window on top *-- of whatever's there save screen to sYesNo *-- save window if there is one, and activate screen to be safe: wWindow = window() activate screen *-- now to define the coordinates ... nULCol = 20 && left side of box nBRCol = 60 && right side of box nWidth = 36 && width of dialog box ... 36 characters for text nHeight = int(len(cMessage)/nWidth) *-- if the remainder of the length of the message/width of box is > 0 *-- we have one more line of text ... nHeight = nHeight + iif(mod(len(cMessage),nWidth)>0,1,0) *-- deal with room for title, and menu at bottom nHeight = nHeight + 4 *-- row coordinates nULRow = (24-nHeight) / 2 && top row nBRRow = nULRow + nHeight + 1 *-- define the window define window wYesNo from nULRow,nULCol to nBRRow,nBRCol double color &cColor *-- now for the menu pads define menu mYesNo define pad pYes of mYesNo prompt "[Yes]" at nHeight - 1,10 define pad pNo of mYesNo prompt "[No]" at nHeight - 1,25 on selection pad pYes of mYesNo deactivate menu on selection pad pNo of mYesNo deactivate menu *-- display it do shadow with nULRow,nULCol,nBRRow,nBRCol activate window wYesNo *-- display title if len(cTitle) < nWidth cTitle = justify(cTitle,39,"C") if len(cTitle) < 39 cTitle = cTitle + " " endif endif cTempCol = colorbrk(cColor,2) cColorF = FBClrBrk("B",cTempCol) cColorB = FBClrBrk("B",colorbrk(cColor,1)) cColorAll = cColorF + "/" + cColorB @0,0 say cTitle color &cTempCol @1,0 say replicate(chr(223),39) color &cColorAll *-- display message do WordWrap with 2,2,cMessage,35 *-- set Y/N keys for menu pad clear typeahead && just to be safe on key label Y keyboard iif(pad() = "PYES","",chr(19))+chr(13) on key label N keyboard iif(pad() = "PNO", "",chr(4) )+chr(13) *-- activate the menu if lDefault activate menu mYesNo pad pYes else activate menu mYesNo pad pNo endif *-- reset system on key label Y on key label N deactivate window wYesNo release window wYesNo restore screen from sYesNo release screen sYesNo release menu mYesNo if .not. isblank(wWindow) activate window &wWindow endif RETURN iif(pad() = "PYES",.t.,.f.) *-- EoF: YesNo3() *------------------------------------------------------------------------------- *-- These functions are here so that we don't have to go hunting all over *------------------------------------------------------------------------------- FUNCTION TempName *------------------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN) Former Sysop, ATBBS *-- Date........: 05-27-1992 *-- Notes.......: Obtain a name for a temporary file of a given extension *-- that does not conflict with existing files. *-- Written for.: dBASE IV, v1.5 *-- Rev. History: Originally part of Makestru(), 6-12-1991 *-- 04/26/92, made a separate function - Jay Parsons *-- 05/27/92, added lDBTMP option - Bowen Moursund *-- Calls.......: None *-- Called by...: Any *-- Usage.......: TempName( cExt , lDBTMP ) *-- Example.....: Sortfile = TempName( "DBF" , .t. ) *-- Returns.....: Name not already in use. Additionally, if the memvar *-- cDBTMP is declared before calling the function with *-- the lDBTMP option, it will be assigned the result *-- of getenv("DBTMP"). *-- Parameters..: cExt = Extension to be given file ( without the "." ) *-- lDBTMP = Optional. If .t., function returns unique file *-- name in the DBTMP subdirectory. *-- Side Effects: The function will return a unique filename for the DEFAULT *-- subdirectory if the lDBTMP option is used and the DOS *-- environment variable DBTMP does not point to a valid *-- subdirectory. *------------------------------------------------------------------------------- parameters cExt, lDBTMP private all except cDBTMP cDefDir = set("DIRECTORY") if lDBTMP cDBTMP = getenv("DBTMP") if "" # cDBTMP set directory to &cDBTMP. endif endif do while .t. Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) ) if .not. file( Fname + "." + cExt ) .and. ( upper( cExt ) # "DBF" .or.; .not. ( file( Fname + ".MDX" ) .or. file ( Fname + ".DBT" ) ) ) exit endif enddo set directory to &cDefDir. RETURN Fname *-- Eof() TempName FUNCTION ArrayRows *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/1992 *-- Notes.......: Number of Rows in an array *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ArrayRows("<aArray>") *-- Example.....: n = ArrayRows("aTest") *-- Returns.....: numeric *-- Parameters..: aArray = Name of array *------------------------------------------------------------------------------- parameters aArray private nHi, nLo, nTrial, nDims nLo = 1 nHi = 1170 if type( "&aArray[ 1, 1 ]" ) = "U" nDims = 1 else nDims = 2 endif do while .T. nTrial = int( ( nHi + nLo ) / 2 ) if nHi < nLo exit endif if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ; nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U" nHi = nTrial - 1 else nLo = nTrial + 1 endif enddo RETURN nTrial *-- EoF: ArrayRows() FUNCTION ArrayCols *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/1992 *-- Notes.......: Number of Columns in an array *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ArrayCols("<aArray>") *-- Example.....: n = ArrayCols("aTest") *-- Returns.....: numeric *-- Parameters..: aArray = Name of array *------------------------------------------------------------------------------- parameters aArray private nHi, nLo, nTrial nLo = 1 nHi = 1170 if type( "&aArray[ 1, 1 ]" ) = "U" RETURN 0 endif do while .t. nTrial = int( ( nHi + nLo ) / 2 ) if nHi < nLo exit endif if type( "&aArray[ 1, nTrial ]" ) = "U" nHi = nTrial - 1 else nLo = nTrial + 1 endif enddo RETURN nTrial *-- EoF: ArrayCol() FUNCTION FieldNum *------------------------------------------------------------------------------- *-- Programmer..: ? *-- Date........: 03/09/1992 *-- Notes.......: Designed to return the number of a given fieldname in the *-- database structure. Works on open database only ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/01/1992 -- Adam L. Menkes for 1.5 ... *-- Calls.......: None *-- Called by...: Any *-- Usage.......: FieldNum("<cFldName>") *-- Example.....: n = FieldNum("Firstname") *-- Returns.....: Numeric *-- Parameters..: cFldName = Name of Field *------------------------------------------------------------------------------- Parameters cFldName cExact = set("EXACT") set exact on nField = 1 do while upper(cFldName) <> FIELD(nField) .and. nField <= fldcount() nField = nField + 1 enddo set exact &cExact RETURN iif(len(trim(field(nField))) = 0,0,nField) *-- EoF: FieldNum() FUNCTION Justify *------------------------------------------------------------------------------- *-- Programmer..: Roland Bouchereau (Ashton-Tate) *-- Date........: 12/23/1992 *-- Notes.......: Used to pad a field/string on the right, left or both, *-- justifying or centering it within the length specified. *-- If the length of the string passed is greater than *-- the size needed, the function will truncate it. *-- Taken from Technotes, June 1990. Defaults to Left Justify *-- if invalid TYPE is passed ... *-- Written for.: dBASE IV, 1.0 *-- Rev. History: Original function 06/15/1991 *-- 12/17/1991 -- Modified into ONE function from three by *-- Ken Mayer, added a third parameter to handle that. *-- 12/23/1992 -- Modified by Joey Carroll to use STUFF() *-- instead of TRANSFORM(). *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Justify(<cFld>,<nLength>,"<cType>") *-- Example.....: ?? Justify(Address,25,"R") *-- Returns.....: Padded/truncated field *-- Parameters..: cFld = Field/Memvar/Character String to justify *-- nLength = Width to justify within *-- cType = Type of justification: L=Left, C=Center,R=Right *------------------------------------------------------------------------------- parameters cFld,nLength,cType private cReturn cType = upper(cType) && just making sure ... if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC" *-- set a picture function of 'X's, with @I,@J or @B function cReturn = space(nLength) cReturn = stuff(cReturn,; iif(cType = "C",(nLength-len(cFld))/2,; iif(cType = "R",nLength-len(cFld)+1,1)),; len(cFld),cFld) else cReturn = "" endif RETURN cReturn *-- EoF: Justify() PROCEDURE WordWrap *------------------------------------------------------------------------------- *-- Programmer..: David Frankenbach (CIS: 72147,2635) *-- Date........: 01/14/1993 (Version 1.1) *-- Notes.......: Wraps a long string, breaking it into strings that have *-- a maximum length of nWidth. The first output is displayed *-- @nRow, nCol. Words are not split ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0) *-- 01/14/1993 -- Version 1.1 -- Corrected side-effect of *-- destroying string arg, added test for *-- string[nWidth+1] = " " *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth> *-- Example.....: do WordWrap with 2,2,cText,38 *-- Returns.....: None *-- Parameters..: nRow = Row to display first line at *-- nCol = Left side of area to display text at *-- cString = text to wrap *-- nWidth = Width of area to wrap text in *------------------------------------------------------------------------------- parameters nRow, nCol, cString, nWidth private cTemp, nI, cStr cStr = cString && work with a COPY of input, to avoid && destroying original do while len(cStr) > 0 && while there's something to work on if (nWidth < len(cStr)) nI = nWidth && look for last " " in first nWidth if substr(cStr,nI+1,1) # " " do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") ) nI = nI - 1 enddo endif if nI = 0 && no spaces nI = nWidth && get first nWidth characters endif else nI = len(cStr) && use the rest of the string endif cTemp = left(cStr,nI) && get the part we're going to display if nI < len(cStr) && remove that part cStr = ltrim(substr(cStr,nI + 1)) else cStr = "" endif *-- display it @nRow,nCol say cTemp *-- move to next row nRow = nRow + 1 enddo RETURN *-- EoP: WordWrap *------------------------------------------------------------------------------- *-- End of Program: WINDOWS.PRG *-------------------------------------------------------------------------------